home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / dwindtst.scm < prev    next >
Text File  |  1999-04-19  |  2KB  |  81 lines
  1. ;;;; "dwindtst.scm", routines for characterizing dynamic-wind.
  2. ;Copyright (C) 1992 Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (require 'dynamic-wind)
  21.  
  22. (define (dwtest n)
  23.   (define cont #f)
  24.   (display "testing escape from thunk") (display n) (newline)
  25.   (display "visiting:") (newline)
  26.   (call-with-current-continuation
  27.    (lambda (x) (set! cont x)))
  28.   (if n
  29.       (dynamic-wind
  30.        (lambda ()
  31.      (display "thunk1") (newline)
  32.      (if (eqv? n 1) (let ((ntmp n))
  33.               (set! n #f)
  34.               (cont ntmp))))
  35.        (lambda ()
  36.      (display "thunk2") (newline)
  37.      (if (eqv? n 2) (let ((ntmp n))
  38.               (set! n #f)
  39.               (cont ntmp))))
  40.        (lambda ()
  41.      (display "thunk3") (newline)
  42.      (if (eqv? n 3) (let ((ntmp n))
  43.               (set! n #f)
  44.               (cont ntmp)))))))
  45. (define (dwctest n)
  46.   (define cont #f)
  47.   (define ccont #f)
  48.   (display "creating continuation thunk") (newline)
  49.   (display "visiting:") (newline)
  50.   (call-with-current-continuation
  51.    (lambda (x) (set! cont x)))
  52.   (if n (set! n (- n)))
  53.   (if n
  54.       (dynamic-wind
  55.        (lambda ()
  56.      (display "thunk1") (newline)
  57.      (if (eqv? n 1) (let ((ntmp n))
  58.               (set! n #f)
  59.               (cont ntmp))))
  60.        (lambda ()
  61.      (call-with-current-continuation
  62.       (lambda (x) (set! ccont x)))
  63.      (display "thunk2") (newline)
  64.      (if (eqv? n 2) (let ((ntmp n))
  65.               (set! n #f)
  66.               (cont ntmp))))
  67.        (lambda ()
  68.      (display "thunk3") (newline)
  69.      (if (eqv? n 3) (let ((ntmp n))
  70.               (set! n #f)
  71.               (cont ntmp))))))
  72.   (cond
  73.    (n
  74.     (set! n (- n))
  75.     (display "testing escape from continuation thunk") (display n) (newline)
  76.     (display "visiting:") (newline)
  77.     (ccont #f))))
  78.  
  79. (dwtest 1) (dwtest 2) (dwtest 3)
  80. (dwctest 1) (dwctest 2) (dwctest 3)
  81.